C $TITLE: 'ETMNS'
C $NOFLOATCALLS
      SUBROUTINE ETMNS(E,ZARRAY,X,Y,Z,BI,SALP,T1X,T1Y,T1Z,T2X,T2Y,
     1 T2Z,P1,P2,P3,P4,P5,P6,ICON1,ICON2,LD,LD2,LD3,IPR)
C
C     ETMNS FILLS THE ARRAY E WITH THE NEGATIVE OF THE ELECTRIC FIELD
C     INCIDENT ON THE STRUCTURE.  E IS THE RIGHT HAND SIDE OF THE MATRIX
C     EQUATION.
C
      REAL*8 TP,RETA,STH,CTH,ARG,SET,CET,SA,CA,WX,WY,WZ
CLARGE: E
      COMPLEX E
      COMPLEX*16 CX,CY,CZ,ER,ET,EZH,ERH,RRV,RRH,TT1,TT2
      COMPLEX*16 ZRATI,ZRATI2,T1,FRATI
      COMPLEX*16 ZARRAY,CDUM,VSANT,VQD,VQDS
      INTEGER*4 ICON1,ICON2,N1,N2,N,NP,M1,M2,M,MP,IPSYM,IS,NEQ
      COMMON/DATAD/N1,N2,N,NP,M1,M2,M,MP,IPSYM,WLAM
      COMMON/VSORC/ VQD(30),VSANT(30),VQDS(30),IVQD(30),ISANT(30),
     1 IQDS(30),NVQD,NSANT,NQDS
      COMMON/GND/ZRATI,ZRATI2,FRATI,CL,CH,SCRWL,SCRWR,NRADL,KSYMP,IFAR,
     1IPERF,T1,T2
      DIMENSION E(LD3),ZARRAY(LD),ICON1(LD),ICON2(LD)
      DIMENSION X(LD),Y(LD),Z(LD),BI(LD),SALP(LD)
      DIMENSION T1X(LD),T1Y(LD),T1Z(LD),T2X(LD),T2Y(LD),T2Z(LD)
      DATA TP/6.283185308D0/,RETA/2.654420938D-3/
C**
C     D      WRITE(*,*) '  ETMNS: START'
      LD2=LD2
C**
      NEQ=N+2*M
      NQDS=0
      IF (IPR.GT.0.AND.IPR.NE.5) GO TO 5
C
C     APPLIED FIELD OF VOLTAGE SOURCES FOR TRANSMITTING CASE
C
      DO 1 I=1,NEQ
1     E(I)=(0.,0.)
      IF (NSANT.EQ.0) GO TO 3
      DO 2 I=1,NSANT
      IS=ISANT(I)
      E(IS)=-VSANT(I)/(T1X(IS)*WLAM)
2      CONTINUE
3     IF (NVQD.EQ.0) RETURN
      DO 4 I=1,NVQD
      IS=IVQD(I)
      CDUM=VQD(I)
      CALL QDSRC(E,ZARRAY,CDUM,X,Y,Z,BI,SALP,T1X,T1Y,
     1 T1Z,T2X,T2Y,T2Z,ICON1,ICON2,IS,LD,LD3)
4      CONTINUE
      RETURN
5     IF (IPR.GT.3) GO TO 19
C
C     INCIDENT PLANE WAVE, LINEARLY POLARIZED.
C
C      CTH=DCOS(P1)
C      STH=DSIN(P1)
C      CPH=DCOS(P2)
C      SPH=DSIN(P2)
C      CET=DCOS(P3)
C      SET=DSIN(P3)
      CTH=COS(P1)
      STH=SIN(P1)
      CPH=COS(P2)
      SPH=SIN(P2)
      CET=COS(P3)
      SET=SIN(P3)
      PX=CTH*CPH*CET-SPH*SET
      PY=CTH*SPH*CET+CPH*SET
      PZ=-STH*CET
      WX=-STH*CPH
      WY=-STH*SPH
      WZ=-CTH
      QX=WY*PZ-WZ*PY
      QY=WZ*PX-WX*PZ
      QZ=WX*PY-WY*PX
      IF (KSYMP.EQ.1) GO TO 7
      IF (IPERF.EQ.1) GO TO 6
C      RRV=CSQRT(1.-ZRATI*ZRATI*STH*STH)
      RRV=ZSQRT(1.-ZRATI*ZRATI*STH*STH)
      RRH=ZRATI*CTH
      RRH=(RRH-RRV)/(RRH+RRV)
      RRV=ZRATI*RRV
      RRV=-(CTH-RRV)/(CTH+RRV)
      GO TO 7
6     RRV=-(1.,0.)
      RRH=-(1.,0.)
7     IF (IPR.GT.1) GO TO 13
      IF (N.EQ.0) GO TO 10
      DO 8 I=1,N
      ARG=-TP*(WX*X(I)+WY*Y(I)+WZ*Z(I))
      CA=DCOS(ARG)
      SA=DSIN(ARG)
8     E(I)=-(PX*T1Y(I)+PY*T1Z(I)+PZ*SALP(I))*DCMPLX(CA,SA)
      IF (KSYMP.EQ.1) GO TO 10
      TT1=(PY*CPH-PX*SPH)*(RRH-RRV)
      CX=RRV*PX-TT1*SPH
      CY=RRV*PY+TT1*CPH
      CZ=-RRV*PZ
      DO 9 I=1,N
      ARG=-TP*(WX*X(I)+WY*Y(I)-WZ*Z(I))
      CA=DCOS(ARG)
      SA=DSIN(ARG)
9     E(I)=E(I)-(CX*T1Y(I)+CY*T1Z(I)+CZ*SALP(I))*DCMPLX(CA,SA)
10    IF (M.EQ.0) RETURN
      I=LD+1
      I1=N-1
      DO 11 IS=1,M
      I=I-1
      I1=I1+2
      I2=I1+1
      ARG=-TP*(WX*X(I)+WY*Y(I)+WZ*Z(I))
      CA=DCOS(ARG)
      SA=DSIN(ARG)
      TT1=DCMPLX(CA,SA)*SALP(I)*RETA
      E(I2)=(QX*T1X(I)+QY*T1Y(I)+QZ*T1Z(I))*TT1
11    E(I1)=(QX*T2X(I)+QY*T2Y(I)+QZ*T2Z(I))*TT1
      IF (KSYMP.EQ.1) RETURN
      TT1=(QY*CPH-QX*SPH)*(RRV-RRH)
      CX=-(RRH*QX-TT1*SPH)
      CY=-(RRH*QY+TT1*CPH)
      CZ=RRH*QZ
      I=LD+1
      I1=N-1
      DO 12 IS=1,M
      I=I-1
      I1=I1+2
      I2=I1+1
      ARG=-TP*(WX*X(I)+WY*Y(I)-WZ*Z(I))
      CA=DCOS(ARG)
      SA=DSIN(ARG)
      TT1=DCMPLX(CA,SA)*SALP(I)*RETA
      E(I2)=E(I2)+(CX*T1X(I)+CY*T1Y(I)+CZ*T1Z(I))*TT1
12    E(I1)=E(I1)+(CX*T2X(I)+CY*T2Y(I)+CZ*T2Z(I))*TT1
      RETURN
C
C     INCIDENT PLANE WAVE, ELLIPTIC POLARIZATION.
C
13    TT1=-(0.,1.)*P6
      IF (IPR.EQ.3) TT1=-TT1
      IF (N.EQ.0) GO TO 16
      CX=PX+TT1*QX
      CY=PY+TT1*QY
      CZ=PZ+TT1*QZ
      DO 14 I=1,N
      ARG=-TP*(WX*X(I)+WY*Y(I)+WZ*Z(I))
      CA=DCOS(ARG)
      SA=DSIN(ARG)
14    E(I)=-(CX*T1Y(I)+CY*T1Z(I)+CZ*SALP(I))*DCMPLX(CA,SA)
      IF (KSYMP.EQ.1) GO TO 16
      TT2=(CY*CPH-CX*SPH)*(RRH-RRV)
      CX=RRV*CX-TT2*SPH
      CY=RRV*CY+TT2*CPH
      CZ=-RRV*CZ
      DO 15 I=1,N
      ARG=-TP*(WX*X(I)+WY*Y(I)-WZ*Z(I))
      CA=DCOS(ARG)
      SA=DSIN(ARG)
15    E(I)=E(I)-(CX*T1Y(I)+CY*T1Z(I)+CZ*SALP(I))*DCMPLX(CA,SA)
16    IF (M.EQ.0) RETURN
      CX=QX-TT1*PX
      CY=QY-TT1*PY
      CZ=QZ-TT1*PZ
      I=LD+1
      I1=N-1
      DO 17 IS=1,M
      I=I-1
      I1=I1+2
      I2=I1+1
      ARG=-TP*(WX*X(I)+WY*Y(I)+WZ*Z(I))
      CA=DCOS(ARG)
      SA=DSIN(ARG)
      TT2=DCMPLX(CA,SA)*SALP(I)*RETA
      E(I2)=(CX*T1X(I)+CY*T1Y(I)+CZ*T1Z(I))*TT2
17    E(I1)=(CX*T2X(I)+CY*T2Y(I)+CZ*T2Z(I))*TT2
      IF (KSYMP.EQ.1) RETURN
      TT1=(CY*CPH-CX*SPH)*(RRV-RRH)
      CX=-(RRH*CX-TT1*SPH)
      CY=-(RRH*CY+TT1*CPH)
      CZ=RRH*CZ
      I=LD+1
      I1=N-1
      DO 18 IS=1,M
      I=I-1
      I1=I1+2
      I2=I1+1
      ARG=-TP*(WX*X(I)+WY*Y(I)-WZ*Z(I))
      CA=DCOS(ARG)
      SA=DSIN(ARG)
      TT1=DCMPLX(CA,SA)*SALP(I)*RETA
      E(I2)=E(I2)+(CX*T1X(I)+CY*T1Y(I)+CZ*T1Z(I))*TT1
18    E(I1)=E(I1)+(CX*T2X(I)+CY*T2Y(I)+CZ*T2Z(I))*TT1
C**
C     D      WRITE(*,*) '  ETMNS: RETURN AFTER 18'
C**
      RETURN
C
C     INCIDENT FIELD OF AN ELEMENTARY CURRENT SOURCE.
C
C19    WZ=DCOS(P4)
C      WX=WZ*DCOS(P5)
C      WY=WZ*DSIN(P5)
C      WZ=DSIN(P4)
19    WZ=COS(P4)
      WX=WZ*COS(P5)
      WY=WZ*SIN(P5)
      WZ=SIN(P4)
      DS=P6*59.958
      DSH=P6/(2.*TP)
      NPM=N+M
      IS=LD+1
      I1=N-1
      DO 24 I=1,NPM
      II=I
      IF (I.LE.N) GO TO 20
      IS=IS-1
      II=IS
      I1=I1+2
      I2=I1+1
20    PX=X(II)-P1
      PY=Y(II)-P2
      PZ=Z(II)-P3
      RS=PX*PX+PY*PY+PZ*PZ
      IF (RS.LT.1.E-30) GO TO 24
      R=SQRT(RS)
      PX=PX/R
      PY=PY/R
      PZ=PZ/R
      CTH=PX*WX+PY*WY+PZ*WZ
      STH=SQRT(1.-CTH*CTH)
      QX=PX-WX*CTH
      QY=PY-WY*CTH
      QZ=PZ-WZ*CTH
      ARG=SQRT(QX*QX+QY*QY+QZ*QZ)
      IF (ARG.LT.1.E-30) GO TO 21
      QX=QX/ARG
      QY=QY/ARG
      QZ=QZ/ARG
      GO TO 22
21    QX=1.
      QY=0.
      QZ=0.
22    ARG=-TP*R
      CA=DCOS(ARG)
      SA=DSIN(ARG)
      TT1=DCMPLX(CA,SA)
      IF (I.GT.N) GO TO 23
      TT2=DCMPLX(1.,-1./(R*TP))/RS
      ER=DS*TT1*TT2*CTH
      ET=.5*DS*TT1*((0.,1.)*TP/R+TT2)*STH
      EZH=ER*CTH-ET*STH
      ERH=ER*STH+ET*CTH
      CX=EZH*WX+ERH*QX
      CY=EZH*WY+ERH*QY
      CZ=EZH*WZ+ERH*QZ
      E(I)=-(CX*T1Y(I)+CY*T1Z(I)+CZ*SALP(I))
      GO TO 24
23    PX=WY*QZ-WZ*QY
      PY=WZ*QX-WX*QZ
      PZ=WX*QY-WY*QX
      TT2=DSH*TT1*DCMPLX(1./R,TP)/R*STH*SALP(II)
      CX=TT2*PX
      CY=TT2*PY
      CZ=TT2*PZ
      E(I2)=CX*T1X(II)+CY*T1Y(II)+CZ*T1Z(II)
      E(I1)=CX*T2X(II)+CY*T2Y(II)+CZ*T2Z(II)
24    CONTINUE
C**
C     D      WRITE(*,*) '  ETMNS: RETURN AT END'
C**
      RETURN
      END
C
C
C
      SUBROUTINE QDSRC(E,ZARRAY,V,X,Y,Z,BI,SALP,T1X,T1Y,
     1 T1Z,T2X,T2Y,T2Z,ICON1,ICON2,IS,LD,LD3)
      REAL*8 TP,CCJX,XI,YI,ZI
C  FILL INCIDENT FIELD ARRAY FOR CHARGE DISCONTINUITY VOLTAGE SOURCE
      REAL*8 AX,BX,CX
CLARGE: E
      COMPLEX E
      COMPLEX*16 CCJ
      COMPLEX*16 CURD,EXK,EYK,EZK,EXS,EYS,EZS,EXC,EYC,EZC,ETK,ETS,ETC
      COMPLEX*16 VQDS,V,VSANT,VQD,ZARRAY
      INTEGER*4 ICON1,ICON2,N1,N2,N,NP,M1,M2,M,MP,IPSYM,IS,IND1,IND2
      COMMON/DATAD/N1,N2,N,NP,M1,M2,M,MP,IPSYM,WLAM
      COMMON/VSORC/ VQD(30),VSANT(30),VQDS(30),IVQD(30),ISANT(30),
     1 IQDS(30),NVQD,NSANT,NQDS
      COMMON/SEGJ/AX(30),BX(30),CX(30),JCO(30),JSNO,ISCON(50),NSCON,
     1 IPCON(10),NPCON
      COMMON/DATAJ/S,B,XJ,YJ,ZJ,CABJ,SABJ,SALPJ,EXK,EYK,EZK,EXS,EYS,
     1 EZS,EXC,EYC,EZC,RKH,IND1,IND2,IPGND,IEXK
      COMMON/ZLOAD/ NLOAD,NLODF
      DIMENSION X(LD),Y(LD),Z(LD),BI(LD),SALP(LD)
      DIMENSION E(LD3),ZARRAY(LD),ICON1(LD),ICON2(LD),CCJX(2)
      DIMENSION T1X(LD),T1Y(LD),T1Z(LD),T2X(LD),T2Y(LD),T2Z(LD)
      EQUIVALENCE (CCJ,CCJX)
      DATA TP/6.283185308D0/,CCJX/0.,-.01666666667D0/
C**
C     D      WRITE(*,*) '   QDSRC: START'
C**
      I=ICON1(IS)
      ICON1(IS)=0
      IDM1=0
      IDM2=IS
      CALL TBF(T1X,BI,ICON1,ICON2,IDM1,IDM2,LD)
      ICON1(IS)=I
      S=T1X(IS)*.5
C      CURD=CCJ*V/((DLOG(2.*S/BI(IS))-1.)*(BX(JSNO)*DCOS(TP*S)+CX(JSNO)
      CURD=CCJ*V/((LOG(2.*S/BI(IS))-1.)*(BX(JSNO)*DCOS(TP*S)+CX(JSNO)
     1*SIN(TP*S))*WLAM)
C     1*DSIN(TP*S))*WLAM)
      NQDS=NQDS+1
      VQDS(NQDS)=V
      IQDS(NQDS)=IS
      DO 20 JX=1,JSNO
      J=JCO(JX)
      S=T1X(J)
      B=BI(J)
      XJ=X(J)
      YJ=Y(J)
      ZJ=Z(J)
      CABJ=T1Y(J)
      SABJ=T1Z(J)
      SALPJ=SALP(J)
      IF (IEXK.EQ.0) GO TO 16
      IPR=ICON1(J)
      IF (IPR) 1,6,2
1     IPR=-IPR
      IF (-ICON1(IPR).NE.J) GO TO 7
      GO TO 4
2     IF (IPR.NE.J) GO TO 3
      IF (CABJ*CABJ+SABJ*SABJ.GT.1.E-8) GO TO 7
      GO TO 5
3     IF (ICON2(IPR).NE.J) GO TO 7
4     XI=ABS(CABJ*T1Y(IPR)+SABJ*T1Z(IPR)+SALPJ*SALP(IPR))
      IF (XI.LT.0.999999) GO TO 7
      IF (ABS(BI(IPR)/B-1.).GT.1.E-6) GO TO 7
5     IND1=0
      GO TO 8
6     IND1=1
      GO TO 8
7     IND1=2
8     IPR=ICON2(J)
      IF (IPR) 9,14,10
9     IPR=-IPR
      IF (-ICON2(IPR).NE.J) GO TO 15
      GO TO 12
10    IF (IPR.NE.J) GO TO 11
      IF (CABJ*CABJ+SABJ*SABJ.GT.1.E-8) GO TO 15
      GO TO 13
11    IF (ICON1(IPR).NE.J) GO TO 15
12    XI=ABS(CABJ*T1Y(IPR)+SABJ*T1Z(IPR)+SALPJ*SALP(IPR))
      IF (XI.LT.0.999999) GO TO 15
      IF (ABS(BI(IPR)/B-1.).GT.1.E-6) GO TO 15
13    IND2=0
      GO TO 16
14    IND2=1
      GO TO 16
15    IND2=2
16    CONTINUE
      DO 17 I=1,N
      IJ=I-J
      XI=X(I)
      YI=Y(I)
      ZI=Z(I)
      AI=BI(I)
      CALL EFLD (XI,YI,ZI,AI,IJ)
      CABI=T1Y(I)
      SABI=T1Z(I)
      SALPI=SALP(I)
      ETK=EXK*CABI+EYK*SABI+EZK*SALPI
      ETS=EXS*CABI+EYS*SABI+EZS*SALPI
      ETC=EXC*CABI+EYC*SABI+EZC*SALPI
17    E(I)=E(I)-(ETK*AX(JX)+ETS*BX(JX)+ETC*CX(JX))*CURD
      IF (M.EQ.0) GO TO 19
      IJ=LD+1
      I1=N
      DO 18 I=1,M
      IJ=IJ-1
      XI=X(IJ)
      YI=Y(IJ)
      ZI=Z(IJ)
      CALL HSFLD (XI,YI,ZI,0.)
      I1=I1+1
      TX=T2X(IJ)
      TY=T2Y(IJ)
      TZ=T2Z(IJ)
      ETK=EXK*TX+EYK*TY+EZK*TZ
      ETS=EXS*TX+EYS*TY+EZS*TZ
      ETC=EXC*TX+EYC*TY+EZC*TZ
      E(I1)=E(I1)+(ETK*AX(JX)+ETS*BX(JX)+ETC*CX(JX))*CURD*SALP(IJ)
      I1=I1+1
      TX=T1X(IJ)
      TY=T1Y(IJ)
      TZ=T1Z(IJ)
      ETK=EXK*TX+EYK*TY+EZK*TZ
      ETS=EXS*TX+EYS*TY+EZS*TZ
      ETC=EXC*TX+EYC*TY+EZC*TZ
18    E(I1)=E(I1)+(ETK*AX(JX)+ETS*BX(JX)+ETC*CX(JX))*CURD*SALP(IJ)
C***
C***    LLNL FIX FM GJB - ADD "*XKU" AT END OF LINE  RWA 03 APR 89
C***
19    IF(NLOAD.GT.0.OR.NLODF.GT.0) E(J)=E(J)+ZARRAY(J)*CURD*(AX(JX)+
     1 CX(JX))*XKU
20    CONTINUE
C**
C D      WRITE(*,*) '   QDSRC: RETURN'
C**
      RETURN
      END
